home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / ir1final.lisp < prev    next >
Lisp/Scheme  |  1991-11-06  |  4KB  |  113 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: ir1final.lisp,v 1.14 91/10/03 18:31:20 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file implements the IR1 finalize phase, which checks for various
  15. ;;; semantic errors.
  16. ;;;
  17. ;;; Written by Rob MacLachlan
  18. ;;;
  19. (in-package 'c)
  20.  
  21.  
  22. ;;; Note-Failed-Optimization  --  Internal
  23. ;;;
  24. ;;;    Give the user grief about optimizations that we weren't able to do.  It
  25. ;;; is assumed that they want to hear, or there wouldn't be any entries in the
  26. ;;; table.  If the node has been deleted or is no longer a known call, then do
  27. ;;; nothing; some other optimization must have gotten to it.
  28. ;;;
  29. (defun note-failed-optimization (node failures)
  30.   (declare (type combination node) (list failures))
  31.   (unless (or (node-deleted node)
  32.           (not (function-info-p (combination-kind node))))
  33.     (let ((*compiler-error-context* node))
  34.       (dolist (failure failures)
  35.     (let ((what (cdr failure))
  36.           (note (transform-note (car failure))))
  37.       (cond
  38.        ((consp what)
  39.         (compiler-note "Unable to ~A because:~%~6T~?"
  40.                note (first what) (rest what)))
  41.        ((valid-function-use node what
  42.                 :argument-test #'types-intersect
  43.                 :result-test #'values-types-intersect)
  44.         (collect ((messages))
  45.           (flet ((frob (string &rest stuff)
  46.                (messages string)
  47.                (messages stuff)))
  48.         (valid-function-use node what
  49.                     :warning-function #'frob
  50.                     :error-function #'frob))
  51.           
  52.           (compiler-note "Unable to ~A due to type uncertainty:~@
  53.                           ~{~6T~?~^~&~}"
  54.                  note (messages))))))))))
  55.  
  56.  
  57. ;;; FINALIZE-XEP-DEFINITION  --  Internal
  58. ;;;
  59. ;;; For each named function with an XEP, note the definition of that name, and
  60. ;;; add derived type information to the info environment.  We also delete the
  61. ;;; FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the possibility that new
  62. ;;; references might be converted to it.
  63. ;;;
  64. (defun finalize-xep-definition (fun)
  65.   (let* ((leaf (functional-entry-function fun))
  66.      (name (leaf-name leaf))
  67.      (dtype (definition-type leaf)))
  68.     (setf (leaf-type leaf) dtype)
  69.     (when (or (and name (symbolp name))
  70.           (and (consp name) (eq (car name) 'setf)))
  71.       (let ((where (info function where-from name))
  72.         (*compiler-error-context* (lambda-bind (main-entry leaf)))
  73.         (global-p (eq leaf (gethash name *free-functions*))))
  74.     (note-name-defined name :function)
  75.     (when global-p
  76.       (remhash name *free-functions*))
  77.     (ecase where
  78.       (:assumed
  79.        (let ((approx-type (info function assumed-type name)))
  80.          (when (and approx-type (function-type-p dtype))
  81.            (valid-approximate-type approx-type dtype))
  82.          (setf (info function type name) dtype)
  83.          (setf (info function assumed-type name) nil))
  84.        (setf (info function where-from name) :defined))
  85.       (:declared); Just keep declared type.
  86.       (:defined
  87.        (setf (info function type name)
  88.          (if global-p dtype (specifier-type 'function))))))))
  89.   (undefined-value))
  90.       
  91.  
  92. ;;; IR1-FINALIZE  --  Interface
  93. ;;;
  94. ;;;    Do miscellaneous things that we want to do once all optimization has
  95. ;;; been done:
  96. ;;;  -- Record the derived result type before the back-end trashes the
  97. ;;;     flow graph.
  98. ;;;  -- Note definition of any entry points.
  99. ;;;  -- Note any failed optimizations.
  100. ;;; 
  101. (defun ir1-finalize (component)
  102.   (declare (type component component))
  103.   (dolist (fun (component-lambdas component))
  104.     (case (functional-kind fun)
  105.       (:external
  106.        (finalize-xep-definition fun))
  107.       ((nil)
  108.        (setf (leaf-type fun) (definition-type fun)))))
  109.  
  110.   (maphash #'note-failed-optimization *failed-optimizations*)
  111.   (clrhash *failed-optimizations*)
  112.   (undefined-value))
  113.